home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Resource V24148852001.psc / mShowResource.bas < prev    next >
Encoding:
BASIC Source File  |  2001-07-19  |  5.7 KB  |  133 lines

  1. Attribute VB_Name = "mShowResource"
  2.  
  3. Private Type RECT
  4.    Left As Long
  5.    Top As Long
  6.    Right As Long
  7.    Bottom As Long
  8. End Type
  9.  
  10. Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
  11. Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
  12. Private Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  13.  
  14. Private Declare Function CreateDialogParam Lib "user32" Alias "CreateDialogParamA" (ByVal hInstance As Long, ByVal lpName As String, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal lParamInit As Long) As Long
  15. Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
  16. Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
  17. Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
  18. Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
  19. Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
  20.  
  21. Public Const TEMP_FILE_NAME = "c:\tempfile.tmp"
  22. Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
  23.  
  24. Public hDialog As Long
  25.  
  26. Public Function ShowAVI(ByVal ResName As String, pb As PictureBox) As Boolean
  27.    Dim arr() As Byte
  28.    Dim mciCmd As String
  29.    Dim nFile As Integer
  30.    Dim sReturn As String * 128
  31.    Dim nWidth As Long, nHeight As Long
  32.    Dim lStart As Long, lPos As Long
  33.    If Dir(TEMP_FILE_NAME) <> "" Then
  34.       Call mciSendString("close video", 0&, 0, 0)
  35.       Kill TEMP_FILE_NAME
  36.    End If
  37.    arr = GetDataArray("AVI", ResName)
  38.    nFile = FreeFile
  39.    Open TEMP_FILE_NAME For Binary As #nFile
  40.       Put #nFile, , arr
  41.    Close #nFile
  42.    mciCmd = "open " & TEMP_FILE_NAME & " Type avivideo Alias video parent " & pb.hWnd & " Style child"
  43.    Call mciSendString(mciCmd, 0&, 0, 0)
  44.    Call mciSendString("Where video destination", ByVal sReturn, Len(sReturn) - 1, 0)
  45.    lStart = InStr(1, sReturn, " ")
  46.    lPos = InStr(lStart + 1, sReturn, " ")
  47.    lStart = InStr(lPos + 1, sReturn, " ")
  48.    nWidth = Mid(sReturn, lPos, lStart - lPos) * Screen.TwipsPerPixelX
  49.    nHeight = Mid(sReturn, lStart + 1) * Screen.TwipsPerPixelY
  50.    pb.Move 0, 0
  51.    If nWidth < picWidth Then pb.Width = picWidth Else pb.Width = nWidth
  52.    If nHeight < picHeight Then pb.Height = picHeight Else pb.Height = nHeight
  53.    Call mciSendString("put video window at " & (pb.Width - nWidth) \ (2 * Screen.TwipsPerPixelX) & " " & (pb.Height - nHeight) \ (2 * Screen.TwipsPerPixelY) & " " & nWidth \ Screen.TwipsPerPixelX & " " & nHeight \ Screen.TwipsPerPixelY, 0&, 0, 0)
  54.    Call mciSendString("play video repeat", 0&, 0, 0)
  55.    ShowAVI = True
  56. End Function
  57.  
  58. Public Function ShowDialog(ByVal ResName As String, pb As PictureBox) As Boolean
  59.    Dim rc As RECT, rcPic As RECT
  60.    hDialog = CreateDialogParam(hModule, ResName, pb.hWnd, 0, 0)
  61.    If hDialog Then
  62.       If GetParent(hDialog) = pb.hWnd Then
  63.          Call GetWindowRect(hDialog, rc)
  64.          Call MoveWindow(hDialog, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, 1)
  65.          pb.Move 0, 0, (rc.Right - rc.Left) * Screen.TwipsPerPixelX, (rc.Bottom - rc.Top + 24) * Screen.TwipsPerPixelY
  66.       Else
  67.          Call GetWindowRect(hDialog, rc)
  68.          Call GetWindowRect(pb.hWnd, rcPic)
  69.          Call MoveWindow(hDialog, rcPic.Left, rcPic.Top, rc.Right - rc.Left, rc.Bottom - rc.Top, 1)
  70.       End If
  71.       Call ShowWindow(hDialog, vbNormalFocus)
  72.       ShowDialog = True
  73.    End If
  74. End Function
  75.  
  76. Public Function ShowPicture(pic As StdPicture, pb As PictureBox) As Boolean
  77.    If pic Is Nothing Then Exit Function
  78.    Dim nWidth As Long, nHeight As Long
  79.    Dim sType As String
  80.    nWidth = pb.ScaleX(pic.Width, vbHimetric, vbTwips)
  81.    nHeight = pb.ScaleY(pic.Height, vbHimetric, vbTwips)
  82.    If nWidth < picWidth Then nWidth = picWidth
  83.    If nHeight < picHeight Then nHeight = picHeight
  84.    pb.Move 0, 0, nWidth, nHeight
  85.    pb.PaintPicture pic, pb.Width \ 2 - pb.ScaleX(pic.Width, vbHimetric, vbTwips) \ 2, pb.Height \ 2 - pb.ScaleY(pic.Height, vbHimetric, vbTwips) \ 2
  86.    pb.CurrentX = 0
  87.    pb.CurrentY = 0
  88.    pb.Print "Image info:" & vbNewLine
  89.    Select Case pic.Type
  90.        Case 0: sType = "None"
  91.        Case 1: sType = "Bitmap (*.bmp)"
  92.             DeleteObject pic.Handle
  93.        Case 2: sType = "Metafile (*.wmf)"
  94.        Case 3: sType = "Icon/cursor (*.ico/*.cur)"
  95.             DestroyIcon pic.Handle
  96.        Case 4: sType = "Enh Metafile (*.emf)"
  97.    End Select
  98.    pb.Print "Type: " & sType
  99.    pb.Print "Syze: " & CInt(pb.ScaleX(pic.Width, vbHimetric, vbPixels)) & " x " & CInt(pb.ScaleY(pic.Height, vbHimetric, vbPixels))
  100.    ShowPicture = True
  101. End Function
  102.  
  103. Public Function ShowText(ByVal sText As String, txt As TextBox) As Boolean
  104.    If sText <> "" Then
  105.       If Len(sText) > 65534 Then
  106.          txt.Text = "Text too long to display it in text box." & vbNewLine & "Save it as file and view with notepad"
  107.          Exit Function
  108.       End If
  109.       txt.Text = sText
  110.       ShowText = True
  111.    End If
  112. End Function
  113.  
  114. Public Sub SaveData(ByVal sFileName As String, arrData As Variant)
  115.    Dim nFile As Integer
  116.    Dim arr() As Byte
  117.    arr = arrData
  118.    nFile = FreeFile
  119.    Open sFileName For Binary As #nFile
  120.       Put #nFile, , arr
  121.    Close #nFile
  122. End Sub
  123.  
  124. Public Sub SaveText(ByVal sFileName As String, sText As String)
  125.    Dim nFile As Integer
  126.    nFile = FreeFile
  127.    Open sFileName For Binary As #nFile
  128.       Put #nFile, , sText
  129.    Close #nFile
  130. End Sub
  131.  
  132.  
  133.